COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		 Here is the LISP source code required to answer HomeWork Set 4
C00016 ENDMK
C⊗;
	; Here is the LISP source code required to answer HomeWork Set 4
	; Spring 1979

 This is the answer to the homework set # 4 
; Handed out: Thursday 19-April; due Thursday 26-April

 ; Answers to Question 1 [MT #5, page 43]

(DEFUN UPTO (U V) 
       (COND ((NULL V) (ERROR-1 '(|Tails do not match|)))
	     ((EQUAL U V) NIL)
	     (T (CONS (CAR V) (UPTO U (CDR V))))))

(DEFUN ERROR-1 (X) (MAPC 'PRINC X) (TERPRI) NIL)
 
   (UPTO  '(A (B C) D) '(P Q R ((S)) T (A (B C D) D) E A (B C) D))
(P Q R ((S)) T (A (B C D) D) E)
   (UPTO  '(A (B C) D) '(P Q R ((S)) T (A (B C D) D) E (A (B C) D)))
Tails do not match
(P Q R ((S)) T (A (B C D) D) E (A (B C) D) NIL)

;; a fancy version of this uses the LISP  THROW/CATCH facility:
(DEFUN UPTO-AUX (U V) 
       (COND ((NULL V) (THROW '|Tails do not match| NOT-MATCH))
	     ((EQUAL U V) NIL)
	     (T (CONS (CAR V) (UPTO-AUX U (CDR V))))))
 
(DEFUN UPTO (U V) (CATCH (UPTO-AUX U V) NOT-MATCH))
;; With this,
   (UPTO  '(A (B C) D) '(P Q R ((S)) T (A (B C D) D) E A (B C) D))
(P Q R ((S)) T (A (B C D) D) E)
   (UPTO  '(A (B C) D) '(P Q R ((S)) T (A (B C D) D) E (A (B C) D)))
|Tails do not match|
 
 

 ; Answers to Question 2 [MT #7, page 44]

(DEFUN MAPCHOOSE (F U) 
       (COND ((NULL U) NIL)
	     ((FUNCALL F (CAR U))
	      (CONS (CAR U) (MAPCHOOSE F (CDR U))))
	     (T (MAPCHOOSE F (CDR U))))) 

  (MAPCHOOSE 'ATOM '(LIST 9 T (PLUS 2 3) 'A (LIST 3) NIL))
(LIST 9 T NIL)
  (MAPCHOOSE 'ATOM  (LIST 9 T (PLUS 2 3) 'A (LIST 3) NIL))
(9 T 5 A NIL)


 ; Answers to Question 3 [MT #12, page 44]

(DEFUN ISPATH (P X) 
       (COND ((NULL P) T)
	     ((ATOM X) NIL)
	     ((ATOM P) (ERROR-1 '(|Not a list |)))
	     ((EQ (CAR P) 'A) (ISPATH (CDR P) (CAR X)))
	     ((EQ (CAR P) 'D) (ISPATH (CDR P) (CDR X)))
	     (T (ERROR-1 (LIST '|Incorrect symbol, | (CAR P))))))

  (ISPATH '(D D A) '(1 2 3 4))
3
  (ISPATH '(D A A) '(1 (2) 3 4))
2
	;; NOTE: We could use the same CATCH/THROW trick again, to get meaningful errors

 ; Answers to Question 4 [MT #17, page 45]

(DEFUN POINT (X Y) 
       (COND ((EQUAL X Y) NIL)
	     ((ATOM Y) '|.¬HERE.|)
	     (((LAMBDA (LEFT) (COND ((EQ LEFT '|.¬HERE.|) NIL)
				    (T (CONS 'A LEFT))))
	       (POINT X (CAR Y))))
		; Here we know X is NOT on left-branch. So try right.
	     (((LAMBDA (RIGHT) (COND ((EQ RIGHT '|.¬HERE.|)
				       |.¬HERE.|)
				     (T (CONS 'D RIGHT))))
	       (POINT X (CDR Y)))))) 

 ; Note: The value |.¬Here.| is used to express the fact that X has not been found in Y
 ; When this value is returned, the search down this branch of the S-expression tree
 ; is abandoned, and only then is the branch farther right interrogated.
 ; Answers to Question 5

;; Part A. (See Part c.)

;; Part B.
(DEFUN PROBABLY-HAS (PAT-NAME DIS-NAME) 
       ((LAMBDA (PAT-REC DIS-REC) 
	; Here we could check if PATient-NAME & DISease-NAME are in the DataBase,
	; by checking if PATient-RECord & DISease-RECord, respectively, are NIL
	  (COND ((NULL DIS-REC) (ERROR-1 (LIST '|Could NOT find disease | DIS-NAME)))
	        ((NULL PAT-REC) (ERROR-1 (LIST '|Could NOT find patient | PAT-NAME)))
		((AND (ANDLIS '(LAMBDA (X) (NOT (MEMQ X (CDR PAT-REC))))
			       (CADDR DIS-REC))
		      (ANDLIS '(LAMBDA (X) (MEMQ X (CDR PAT-REC)))
			       (CADR DIS-REC)))
		 DIS-NAME) ;; ← So if tests (↑) pass, the name of the disease is returned
		(T NIL)))
	(ASSQ PAT-NAME PATIENTS)
	(ASSQ DIS-NAME DISEASES))) 

(DEFUN ANDLIS (F U) 
	; Applies function F to each member of list U, & returns AND-junction of resultant list
       (COND ((NULL U) T)
	     (T (AND (FUNCALL F (CAR U)) (ANDLIS F (CDR U)))))) 

(DEFUN MAPCHOOSE-1 (F U) 
	   ; This returns a list, whose elements are of the form (F u), where
	   ;   u ε U and (F u) is non-NIL
	   ;  [NOTE: MAPCHOOSE would have returned the element "u" if (↑) satisfied]
       (COND ((NULL U) NIL)
	     (((LAMBDA (TEST) 
	         (AND TEST (CONS test (MAPCHOOSE-1 F (CDR U)))))
			; if test is NIL, falls thru. Else, CONSes it to front
		(FUNCALL F (CAR U))))
	     (T (MAPCHOOSE-1 F (CDR U))))) 

;; For PART C.
	; PROBABLY-HAS returns the DISEASE name so other functions, 
	; ( MAP-CHOOSE-1 in this example,) can use this value. 
	; If T was returned, the vaue of this disease would have to be redetermined.

(DEFUN DIAGNOSES (PATIENTS DISEASES) 
       (MAPCAR 
	'(LAMBDA (PAT-REC) 
		((LAMBDA (PAT-NAME)
		   (CONS PAT-NAME
			 (MAPCHOOSE-1 '(LAMBDA (DIS-REC)
					 (PROBABLY-HAS PAT-NAME (CAR DIS-REC)))
				      DISEASES)))
		 (CAR PAT-REC)))
	PATIENTS))

  (DIAGNOSES PATIENTS DISEASES) 
((RDG HEALTHY)
 (DBL HEALTHY)
 (BCM LACONIC-NESS FEAR-OF-FRYING)
 (CLEOPATRA CHICKEN-POX)
 (DOLLAR FAIL-LISP-CLASS MIDAS-TOUCH INSANITY)
 (ICARUS FEAR-OF-FLYING HEALTHY)
 (FISHER CHESS-ITIS HEALTHY)
 (PAULING HAYFEVER COLD)
 (BIGMOUTH FAIL-LISP-CLASS VERBOSITY HEALTHY)
 (BIGMOUTH2 FAIL-LISP-CLASS LACONIC-NESS HEALTHY)
 (NOTHING HEALTHY)
 (DIRTYNEEDLE HEPATITUS)
 (SMALLTALK LACONIC-NESS HEALTHY)
 (ROBBERBARON GERMAN-MEASLES)
 (MRHANGOVER ALCOHOLISM)
 (JOESTUDENT TIRED-OF-LOTS HEPATITUS)
 (MRABACUS FEAR-OF-FLYING FUTURE-SHOCK))
 

;; For PART D.
(DEFUN WHO-HAS (DIS-NAME) 
       (COND
	((ASSQ DIS-NAME DISEASES)
	 (MAPCHOOSE-1 '(LAMBDA (PAT) 
			       ((LAMBDA (PAT-NAME) 
					(AND (PROBABLY-HAS PAT-NAME
							   DIS-NAME)
					     PAT-NAME))
				(CAR PAT)))
		      PATIENTS))
	(T (ERROR-1 (LIST '|Could NOT find disease |
			DIS-NAME)))))
 

  (WHO-HAS 'CHICKEN-POX)
(CLEOPATRA)
  (WHO-HAS 'HEALTHY)
(RDG DBL ICARUS FISHER BIGMOUTH BIGMOUTH2 NOTHING SMALLTALK)
  (WHO-HAS 'FRED)
Could NOT find disease FRED
NIL

 ; Answers to Question 6

(DEFUN PGM NIL 
       ((LAMBDA (NAME) 
		((LAMBDA (COMBINE WHEN-ATOM) 
			 (PRINT 'DONE)
			 (LIST 'DEFUN
			       NAME
			       '(X)
			       (LIST 'COND
				     (LIST '(ATOM X) WHEN-ATOM)
				     (LIST T
					   (LIST COMBINE
						 (LIST NAME
						       '(CAR X))
						 (LIST NAME
						       '(CDR X)))))))
		 (READ-IN (LIST '|How to combine (|
				NAME
				'| (car X) ) with (|
				NAME
				'| (cdr X) )|))
		 (READ-IN '(|What to return if X is an atom|))))
	(READ-IN '(|Name of the Function you wish to define|)))) 

(DEFUN READ-IN (OUTPUT) 
       (MAPC 'PRINC OUTPUT)
       (PRINC '|:  |)
       (READ)) 

  ;;; Test runs of PGM  [my input in lower case, response in UPPER]

(setq honest (pgm))
Name of the Function you wish to define:  diogenes
How to combine (DIOGENES (car X) ) with (DIOGENES (cdr X) ):  or
What to return if X is an atom:  (eq x t)
DONE
(DEFUN DIOGENES (X) 
       (COND ((ATOM X) (EQ X T))
	     (T (OR (DIOGENES (CAR X)) (DIOGENES (CDR X))))))
 
(eval honest)
DIOGENES 
(diogenes '(2 3 (4 . 5) . 7))
NIL 
(diogenes '(2 3 (4 . t) . 7))
T 

(setq count-em (pgm))
Name of the Function you wish to define:  natoms
How to combine (NATOMS (car X) ) with (NATOMS (cdr X) ):  plus
What to return if X is an atom:  1
DONE
(DEFUN NATOMS (X) 
       (COND ((ATOM X) 1)
	     (T (PLUS (NATOMS (CAR X)) (NATOMS (CDR X))))))
(eval count-em)
NATOMS 
(natoms '(7 (8 . 4) fred . NIL))
5 
(natoms '((7 (8 . 4) fred . NIL)))
6 

(setq shallow (pgm))
Name of the Function you wish to define:  flaten
How to combine (FLATEN (car X) ) with (FLATEN (cdr X) ):  append
What to return if X is an atom:  (list x)
DONE
(DEFUN FLATEN (X) 
       (COND ((ATOM X) (LIST X))
	     (T (APPEND (FLATEN (CAR X)) (FLATEN (CDR X))))))
(eval shallow)
FLATEN 
(flaten '(7 (t george . 4) (5 6) . NIL))
(7 T GEORGE 4 5 6 NIL NIL)